home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / scheme2c / rec-28se.pat / shlibs / shlibscx / hexname.sc next >
Encoding:
Text File  |  1994-06-30  |  8.4 KB  |  191 lines
  1. ;;;
  2. ;;; The external symbols emitted by Scheme->C have been pulverized by the
  3. ;;; following routines from scsc/expform.sc.
  4. ;;; This program is intended to run as a filter reading cat xlib/*.sch and
  5. ;;; writing out the list of exported C symbols which need to be made visible
  6. ;;; in the shared library.  The supplied libscx.export is the result, it won't
  7. ;;; need changing unless you modify the contents of xlib.
  8. ;;;
  9.  
  10. (module hexname (main main))
  11.  
  12. ;;; This function is called to convert a name into its "lower case hex" format.
  13.  
  14. (define (LCHEXNAME name)
  15.     (if (symbol? name) (set! name (symbol->string name)))
  16.     (do ((c '())
  17.      (i 0 (+ 1 i))
  18.      (new (list 1)))
  19.     ((= i (string-length name)) (list->string (cdr new)))
  20.     (set! c (string-ref name i))
  21.     (cond ((char=? c #\_)
  22.            (set-cdr! (last-pair new) (list #\_ #\_)))
  23.           ((and (char>=? c #\A) (char<=? c #\Z))
  24.            (set-cdr! (last-pair new)
  25.            (list (integer->char (+ (char->integer c) 32)))))
  26.           ((or (and (char>=? c #\a) (char<=? c #\z))
  27.            (and (char>=? c #\0) (char<=? c #\9) (> i 0)))
  28.            (set-cdr! (last-pair new) (list c)))
  29.           (else
  30.         (set-cdr! (last-pair new) (cons #\_ (char->dl c 16 2)))))))
  31.  
  32. ;;; This function is one of those that you hope you never have to write, but
  33. ;;; inevitably you must.  It exists because vcc will only recognize the first
  34. ;;; 31 characters of a variable name.  In order to force the first 31
  35. ;;; characters of a generated name to be unique, it is necessary that the
  36. ;;; lchexnames of the module and variable be less than or equal to 28
  37. ;;; characters.  If it doesn't fit, then a name is generated consisting of
  38. ;;; the last 9 characters of the module name, the last 10 characters of the
  39. ;;; name, and the hex crc-32 of the module and name.
  40.  
  41. (define (HEX28 module name)
  42.     (if (<= (+ (string-length module) (string-length name)) 28)
  43.     (if (equal? module "") name (string-append module "_" name))
  44.     (let ((value (format '() "~a_~a_~a"
  45.                  (substring module
  46.                  (max 0 (- (string-length module) 9))
  47.                  (string-length module))
  48.                  (substring name
  49.                  (max 0 (- (string-length name) 10))
  50.                  (string-length name))
  51.                  (crc-32x2 (string->list
  52.                        (string-append module name)) 0 0))))
  53.          (if (char-numeric? (string-ref value 0))
  54.          (string-set! value 0 #\_))
  55.          value)))
  56.  
  57. ;;; Compute a crc-32 for a list of characters using a per character table and
  58. ;;; return a string with the hex value.  The crc is computed in two 16-bit
  59. ;;; integers to avoid having to use floating point numbers.
  60.  
  61. (define (CRC-32x2 chars crc-left crc-right)
  62.     (if (null? chars)
  63.     (let loop ((cl '()) (left crc-left) (right crc-right))
  64.          (if (and (zero? left) (zero? right))
  65.          (if (null? cl) "0" (list->string cl))
  66.          (loop (cons (string-ref "0123456789abcdef"
  67.                  (remainder right 16))
  68.                  cl)
  69.                (quotient left 16)
  70.                (+ (bit-lsh (remainder left 16) 12)
  71.               (quotient right 16)))))
  72.     (let ((char (char->integer (car chars))))
  73.          (crc-32x2 (cdr chars)
  74.          (bit-xor (bit-rsh crc-left 8)
  75.              (vector-ref t-left char)
  76.              (vector-ref t-left (remainder crc-right 256)))
  77.          (bit-xor (bit-or (bit-lsh (bit-and crc-left 255) 8)
  78.                   (bit-rsh crc-right 8))
  79.              (vector-ref t-right char)
  80.              (vector-ref t-right (remainder crc-right 256)))))))
  81.  
  82. (define T-LEFT '#(
  83.   #x0000  #x7707  #xEE0E  #x9909  #x076D  #x706A  #xE963  #x9E64
  84.   #x0EDB  #x79DC  #xE0D5  #x97D2  #x09B6  #x7EB1  #xE7B8  #x90BF
  85.   #x1DB7  #x6AB0  #xF3B9  #x84BE  #x1ADA  #x6DDD  #xF4D4  #x83D3
  86.   #x136C  #x646B  #xFD62  #x8A65  #x1401  #x6306  #xFA0F  #x8D08
  87.   #x3B6E  #x4C69  #xD560  #xA267  #x3C03  #x4B04  #xD20D  #xA50A
  88.   #x35B5  #x42B2  #xDBBB  #xACBC  #x32D8  #x45DF  #xDCD6  #xABD1
  89.   #x26D9  #x51DE  #xC8D7  #xBFD0  #x21B4  #x56B3  #xCFBA  #xB8BD
  90.   #x2802  #x5F05  #xC60C  #xB10B  #x2F6F  #x5868  #xC161  #xB666
  91.   #x76DC  #x01DB  #x98D2  #xEFD5  #x71B1  #x06B6  #x9FBF  #xE8B8
  92.   #x7807  #x0F00  #x9609  #xE10E  #x7F6A  #x086D  #x9164  #xE663
  93.   #x6B6B  #x1C6C  #x8565  #xF262  #x6C06  #x1B01  #x8208  #xF50F
  94.   #x65B0  #x12B7  #x8BBE  #xFCB9  #x62DD  #x15DA  #x8CD3  #xFBD4
  95.   #x4DB2  #x3AB5  #xA3BC  #xD4BB  #x4ADF  #x3DD8  #xA4D1  #xD3D6
  96.   #x4369  #x346E  #xAD67  #xDA60  #x4404  #x3303  #xAA0A  #xDD0D
  97.   #x5005  #x2702  #xBE0B  #xC90C  #x5768  #x206F  #xB966  #xCE61
  98.   #x5EDE  #x29D9  #xB0D0  #xC7D7  #x59B3  #x2EB4  #xB7BD  #xC0BA
  99.   #xEDB8  #x9ABF  #x03B6  #x74B1  #xEAD5  #x9DD2  #x04DB  #x73DC
  100.   #xE363  #x9464  #x0D6D  #x7A6A  #xE40E  #x9309  #x0A00  #x7D07
  101.   #xF00F  #x8708  #x1E01  #x6906  #xF762  #x8065  #x196C  #x6E6B
  102.   #xFED4  #x89D3  #x10DA  #x67DD  #xF9B9  #x8EBE  #x17B7  #x60B0
  103.   #xD6D6  #xA1D1  #x38D8  #x4FDF  #xD1BB  #xA6BC  #x3FB5  #x48B2
  104.   #xD80D  #xAF0A  #x3603  #x4104  #xDF60  #xA867  #x316E  #x4669
  105.   #xCB61  #xBC66  #x256F  #x5268  #xCC0C  #xBB0B  #x2202  #x5505
  106.   #xC5BA  #xB2BD  #x2BB4  #x5CB3  #xC2D7  #xB5D0  #x2CD9  #x5BDE
  107.   #x9B64  #xEC63  #x756A  #x026D  #x9C09  #xEB0E  #x7207  #x0500
  108.   #x95BF  #xE2B8  #x7BB1  #x0CB6  #x92D2  #xE5D5  #x7CDC  #x0BDB
  109.   #x86D3  #xF1D4  #x68DD  #x1FDA  #x81BE  #xF6B9  #x6FB0  #x18B7
  110.   #x8808  #xFF0F  #x6606  #x1101  #x8F65  #xF862  #x616B  #x166C
  111.   #xA00A  #xD70D  #x4E04  #x3903  #xA767  #xD060  #x4969  #x3E6E
  112.   #xAED1  #xD9D6  #x40DF  #x37D8  #xA9BC  #xDEBB  #x47B2  #x30B5
  113.   #xBDBD  #xCABA  #x53B3  #x24B4  #xBAD0  #xCDD7  #x54DE  #x23D9
  114.   #xB366  #xC461  #x5D68  #x2A6F  #xB40B  #xC30C  #x5A05  #x2D02
  115. ))
  116.  
  117. (define T-RIGHT '#(
  118.   #x0000  #x3096  #x612C  #x51BA  #xC419  #xF48F  #xA535  #x95A3
  119.   #x8832  #xB8A4  #xE91E  #xD988  #x4C2B  #x7CBD  #x2D07  #x1D91
  120.   #x1064  #x20F2  #x7148  #x41DE  #xD47D  #xE4EB  #xB551  #x85C7
  121.   #x9856  #xA8C0  #xF97A  #xC9EC  #x5C4F  #x6CD9  #x3D63  #x0DF5
  122.   #x20C8  #x105E  #x41E4  #x7172  #xE4D1  #xD447  #x85FD  #xB56B
  123.   #xA8FA  #x986C  #xC9D6  #xF940  #x6CE3  #x5C75  #x0DCF  #x3D59
  124.   #x30AC  #x003A  #x5180  #x6116  #xF4B5  #xC423  #x9599  #xA50F
  125.   #xB89E  #x8808  #xD9B2  #xE924  #x7C87  #x4C11  #x1DAB  #x2D3D
  126.   #x4190  #x7106  #x20BC  #x102A  #x8589  #xB51F  #xE4A5  #xD433
  127.   #xC9A2  #xF934  #xA88E  #x9818  #x0DBB  #x3D2D  #x6C97  #x5C01
  128.   #x51F4  #x6162  #x30D8  #x004E  #x95ED  #xA57B  #xF4C1  #xC457
  129.   #xD9C6  #xE950  #xB8EA  #x887C  #x1DDF  #x2D49  #x7CF3  #x4C65
  130.   #x6158  #x51CE  #x0074  #x30E2  #xA541  #x95D7  #xC46D  #xF4FB
  131.   #xE96A  #xD9FC  #x8846  #xB8D0  #x2D73  #x1DE5  #x4C5F  #x7CC9
  132.   #x713C  #x41AA  #x1010  #x2086  #xB525  #x85B3  #xD409  #xE49F
  133.   #xF90E  #xC998  #x9822  #xA8B4  #x3D17  #x0D81  #x5C3B  #x6CAD
  134.   #x8320  #xB3B6  #xE20C  #xD29A  #x4739  #x77AF  #x2615  #x1683
  135.   #x0B12  #x3B84  #x6A3E  #x5AA8  #xCF0B  #xFF9D  #xAE27  #x9EB1
  136.   #x9344  #xA3D2  #xF268  #xC2FE  #x575D  #x67CB  #x3671  #x06E7
  137.   #x1B76  #x2BE0  #x7A5A  #x4ACC  #xDF6F  #xEFF9  #xBE43  #x8ED5
  138.   #xA3E8  #x937E  #xC2C4  #xF252  #x67F1  #x5767  #x06DD  #x364B
  139.   #x2BDA  #x1B4C  #x4AF6  #x7A60  #xEFC3  #xDF55  #x8EEF  #xBE79
  140.   #xB38C  #x831A  #xD2A0  #xE236  #x7795  #x4703  #x16B9  #x262F
  141.   #x3BBE  #x0B28  #x5A92  #x6A04  #xFFA7  #xCF31  #x9E8B  #xAE1D
  142.   #xC2B0  #xF226  #xA39C  #x930A  #x06A9  #x363F  #x6785  #x5713
  143.   #x4A82  #x7A14  #x2BAE  #x1B38  #x8E9B  #xBE0D  #xEFB7  #xDF21
  144.   #xD2D4  #xE242  #xB3F8  #x836E  #x16CD  #x265B  #x77E1  #x4777
  145.   #x5AE6  #x6A70  #x3BCA  #x0B5C  #x9EFF  #xAE69  #xFFD3  #xCF45
  146.   #xE278  #xD2EE  #x8354  #xB3C2  #x2661  #x16F7  #x474D  #x77DB
  147.   #x6A4A  #x5ADC  #x0B66  #x3BF0  #xAE53  #x9EC5  #xCF7F  #xFFE9
  148.   #xF21C  #xC28A  #x9330  #xA3A6  #x3605  #x0693  #x5729  #x67BF
  149.   #x7A2E  #x4AB8  #x1B02  #x2B94  #xBE37  #x8EA1  #xDF1B  #xEF8D
  150. ))
  151.  
  152. ;;; This function converts the character "c" into numeric string of length
  153. ;;; "len" in base "base".
  154.  
  155. (define (CHAR->DL c base len)
  156.     (set! c (char->integer c))
  157.     (do ((dl '()))
  158.     ((zero? len) dl)
  159.     (set! dl (cons (string-ref "0123456789abcdef" (remainder c base)) dl))
  160.     (set! c (quotient c base))
  161.     (set! len (- len 1))))
  162.  
  163. (define (main clargs)
  164.   (define (write-hex28 input-form)
  165.     (define (form-is? x)
  166.       (eq? (car input-form) x))
  167.     (define (form-module)
  168.       (lchexname (caddr input-form)))
  169.     (define (form-symbol)
  170.       (lchexname
  171.        (if (pair? (cadr input-form))
  172.        (caadr input-form)
  173.        (cadr input-form))))
  174.     (cond ((form-is? 'define-c-external) #f)
  175.       ((form-is? 'define-constant) #f)
  176.       ((form-is? 'define-external)
  177.        (let ((hexname (hex28 (form-module) (form-symbol))))
  178.          (display hexname)
  179.          (newline)
  180.          (display (string-append hexname "_v"))
  181.          (newline)))
  182.       (else
  183.        (error 'write-hex28 "Unrecognized form: ~s" input-form))))
  184.   (define (read-form)
  185.     (let ((input (read)))
  186.       (when (not (eof-object? input))
  187.     (write-hex28 input)
  188.     (read-form))))
  189.   (read-form)
  190.   (exit))
  191.